home *** CD-ROM | disk | FTP | other *** search
/ Aminet 24 / Aminet 24 (1998)(GTI - Schatztruhe)[!][Apr 1998].iso / Aminet / dev / c / AmiVoGL_MDEV.lha / examples / flcube.F < prev    next >
Text File  |  1991-06-07  |  3KB  |  184 lines
  1.  
  2.     program flcube
  3.  
  4. #ifdef SGI
  5. #include "fgl.h"
  6. #include "fdevice.h"
  7. #else
  8. #include "fvogl.h"
  9. #include "fvodevice.h"
  10. #endif
  11.  
  12.     integer x, y, but
  13.     integer *2 val
  14.  
  15.     parameter(TRANS = 20.0, SC = 0.1)
  16.  
  17.     call prefsi(500, 500)
  18.  
  19.     call winope('flcube', 6)
  20.  
  21.     call unqdev(INPUTC)
  22.     call qdevic(SKEY)
  23.     call qdevic(XKEY)
  24.     call qdevic(YKEY)
  25.     call qdevic(ZKEY)
  26.     call qdevic(EQUALK)
  27.     call qdevic(MINUSK)
  28.     call qdevic(ESCKEY)
  29.     call qdevic(QKEY)
  30.  
  31.     call window(-800.0, 800.0, -800.0, 800.0, -800.0, 800.0)
  32.     call lookat(0.0, 0.0, 1500.0, 0.0, 0.0, 0.0, 0)
  33.  
  34.     tdir = TRANS
  35.     scal = SC
  36.  
  37.     nplanes = getpla()
  38.     if (nplanes .eq. 1) call makecu(0)
  39.  
  40.     call makecu(1)
  41.  
  42.     call backfa(.true.)
  43. c
  44. c Setup drawing into the backbuffer....
  45. c
  46.     call double
  47.     call gconfi
  48.  
  49. 1    continue
  50.         x = 500 - getval(MOUSEX)
  51.         y = 500 - getval(MOUSEY)
  52.         x = x * 3
  53.         y = y * 3
  54.         call pushma
  55.             call rotate(x, 'y')
  56.             call rotate(y, 'x')
  57.             call color(BLACK)
  58.             call clear
  59.             call callob(3)
  60.             if (nplanes .eq. 1) call callob(2)
  61.         call popmat
  62.         call swapbu
  63.  
  64.         
  65.         if (qtest()) then
  66.             but = qread(val)
  67.             if (but .eq. XKEY) then
  68.                 call transl(tdir, 0.0, 0.0)
  69.             else if (but .eq. YKEY) then
  70.                 call transl(0.0, tdir, 0.0)
  71.             else if (but .eq. ZKEY) then
  72.                 call transl(0.0, 0.0, tdir)
  73.             else if (but .eq. SKEY) then
  74.                 call scale(scal, scal, scal)
  75.             else if (but .eq. MINUSK) then
  76.                 tdir = -tdir
  77.             
  78.                 if (scal .lt. 1.0) then
  79.                     scal = 1.0 + SC
  80.                 else
  81.                     scal = 1.0 - SC
  82.                 end if
  83.  
  84.             else if (but .eq. EQUALK) then
  85. c
  86. c                we are pretending it's a '+' key
  87. c                we are supposed to see if the shift key is
  88. c                also down - but who could be bothered!
  89. c
  90.                 tdir = TRANS
  91.             else if (but .eq. QKEY .or. but .eq. ESCKEY) then
  92.                 call gexit
  93.                 stop
  94.             end if
  95. c
  96. c            Swallow the UP event...
  97. c
  98.             but = qread(val)
  99.         end if
  100.     goto 1
  101.     end
  102.  
  103.     subroutine makecu(fill)
  104. #include "fvogl.h"
  105.     integer    fill
  106.  
  107.     call makeob(fill + 2)
  108.         if (fill .ne. 0) then
  109.             call polymo(PYM_FI)
  110.         else
  111.             call polymo(PYM_LI)
  112.             call color(BLACK)
  113.         end if
  114.  
  115.         call pushma
  116.             call transl(0.0, 0.0, 200.0)
  117.             if (fill .ne. 0) then 
  118.                 call color(RED)
  119.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  120.             else
  121.                 call rect(-200.0, -200.0, 200.0, 200.0)
  122.             end if
  123.         call popmat
  124.  
  125.         call pushma
  126.             call transl(200.0, 0.0, 0.0)
  127.             call rotate(900, 'y')
  128.             if (fill .ne. 0) then
  129.                 call color(GREEN)
  130.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  131.             else
  132.                 call rect(-200.0, -200.0, 200.0, 200.0)
  133.             end if
  134.         call popmat
  135.  
  136.         call pushma
  137.             call transl(0.0, 0.0, -200.0)
  138.             call rotate(1800, 'y')
  139.             if (fill .ne. 0) then
  140.                 call color(BLUE)
  141.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  142.             else
  143.                 call rect(-200.0, -200.0, 200.0, 200.0)
  144.             end if
  145.         call popmat
  146.  
  147.         call pushma
  148.             call transl(-200.0, 0.0, 0.0)
  149.             call rotate(-900, 'y')
  150.             if (fill .ne. 0) then
  151.                 call color(CYAN)
  152.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  153.             else
  154.                 call rect(-200.0, -200.0, 200.0, 200.0)
  155.             end if
  156.         call popmat
  157.  
  158.         call pushma
  159.             call transl(0.0, 200.0, 0.0)
  160.             call rotate(-900, 'x')
  161.             if (fill .ne. 0) then
  162.                 call color(MAGENT)
  163.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  164.             else
  165.                 call rect(-200.0, -200.0, 200.0, 200.0)
  166.             end if
  167.         call popmat
  168.  
  169.         call pushma
  170.             call transl(0.0, -200.0, 0.0)
  171.             call rotate(900, 'x')
  172.             if (fill .ne. 0) then
  173.                 call color(YELLOW)
  174.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  175.             else
  176.                 call rect(-200.0, -200.0, 200.0, 200.0)
  177.             end if
  178.         call popmat
  179.  
  180.     call closeo
  181.  
  182.     return
  183.     end
  184.